home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
DELPHI32
/
TOOLBARS
/
TRACKBAR
/
TRACKBAR.ZIP
/
TRACKBAR.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-01-06
|
13KB
|
385 lines
unit Trackbar;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs;
const
TBS_AUTOTICKS = $0001;
TBS_VERT = $0002;
TBS_LEFT = $0004;
TBS_BOTH = $0008;
TBS_NOTICKS = $0010;
TBS_ENABLESELRANGE = $0020;
TBS_FIXEDLENGTH = $0040;
TBS_NOTHUMB = $0080;
TBM_GETPOS = WM_USER; {}
TBM_GETRANGEMIN = WM_USER+1; {}
TBM_GETRANGEMAX = WM_USER+2; {}
TBM_GETTIC = WM_USER+3; {}
TBM_SETTIC = WM_USER+4; {}
TBM_SETPOS = WM_USER+5; {}
TBM_SETRANGE = WM_USER+6; {}
TBM_SETRANGEMIN = WM_USER+7; {}
TBM_SETRANGEMAX = WM_USER+8; {}
TBM_CLEARTICS = WM_USER+9; {}
TBM_SETSEL = WM_USER+10; {}
TBM_SETSELSTART = WM_USER+11; {}
TBM_SETSELEND = WM_USER+12; {}
TBM_GETPTICS = WM_USER+14;
TBM_GETTICPOS = WM_USER+15; {}
TBM_GETNUMTICS = WM_USER+16; {}
TBM_GETSELSTART = WM_USER+17; {}
TBM_GETSELEND = WM_USER+18; {}
TBM_CLEARSEL = WM_USER+19; {}
TBM_SETTICFREQ = WM_USER+20; {}
TBM_SETPAGESIZE = WM_USER+21; {}
TBM_GETPAGESIZE = WM_USER+22; {}
TBM_SETLINESIZE = WM_USER+23; {}
TBM_GETLINESIZE = WM_USER+24; {}
TBM_GETTHUMBRECT = WM_USER+25; {}
TBM_GETCHANNELRECT = WM_USER+26; {}
TBM_SETTHUMBLENGTH = WM_USER+27; {}
TBM_GETTHUMBLENGTH = WM_USER+28; {}
TB_LINEUP = 0;
TB_LINEDOWN = 1;
TB_PAGEUP = 2;
TB_PAGEDOWN = 3;
TB_THUMBPOSITION = 4;
TB_THUMBTRACK = 5;
TB_TOP = 6;
TB_BOTTOM = 7;
TB_ENDTRACK = 8;
{
TB_BOTTOM VK_END
TB_ENDTRACK WM_KEYUP (the user released a key that sent a relevant virtual-key code)
TB_LINEDOWN VK_RIGHT or VK_DOWN
TB_LINEUP VK_LEFT or VK_UP
TB_PAGEDOWN VK_NEXT (the user clicked the channel below or to the right of the slider)
TB_PAGEUP VK_PRIOR (the user clicked the channel above or to the left of the slider)
TB_THUMBPOSITION WM_LBUTTONUP following a TB_THUMBTRACK notification message
TB_THUMBTRACK Slider movement (the user dragged the slider)
TB_TOP VK_HOMEtype
}
type
tbStyle = (tbAutoticks, tbVert, tbReversed, tbBoth, tbNoTicks, tbEnableSelRange, tbFixedLength, tbNoThumb);
tbStyles = set of tbStyle;
TTrackbarKind = (tkHoriz, tkVert);
TTrackbar = class(TWinControl)
private
Styles : tbStyles;
iMax : LongInt;
iMin : LongInt;
iSelectionStart : Longint;
iSelectionEnd : LongInt;
iPos : LongInt;
iTickFreq : Integer;
iLineSize, iPageSize : LongInt;
iThumbLength : Integer;
EvLineUp : TNotifyEvent;
EvLineDown : TNotifyEvent;
EvPageUp : TNotifyEvent;
EvPageDown : TNotifyEvent;
EvThumbPosition : TNotifyEvent;
EvThumbTrack : TNotifyEvent;
EvTop : TNotifyEvent;
EvBottom : TNotifyEvent;
EvEndTrack : TNotifyEvent;
procedure SetMin (value : LongInt);
procedure SetMax (value : LongInt);
procedure SetSelectionStart (value : LongInt);
procedure SetSelectionEnd (value : LongInt);
procedure SetPos (value : LongInt);
function GetPos : LongInt;
procedure SetStyles (value : tbStyles);
procedure SetTickFreq (value : Integer);
procedure SetPageSize (value : LongInt);
procedure SetLineSize (value : LongInt);
procedure SetThumbLength (value : Integer);
procedure wmHScroll (var Msg : TMessage); message CN_HSCROLL;
protected
constructor Create (AOwner : TComponent); override;
procedure CreateParams (var Params: TCreateParams); override;
procedure CreateHandle; override;
public
procedure SetTic (position : LongInt);
function GetTic (index : Integer) : LongInt;
function GetTicPos (index : Integer) : LongInt;
procedure ClearTics (Redraw : boolean);
function GetNumTics : Integer;
procedure ClearSelection (Redraw : boolean);
procedure GetThumbRect (var Rect : TRect);
procedure GetChannelRect (var Rect : TRect);
published
property Min : LongInt read iMin write SetMin;
property Max : LongInt read iMax write SetMax;
property SelectionStart : LongInt read iSelectionStart write SetSelectionStart;
property SelectionEnd : LongInt read iSelectionEnd write SetSelectionEnd;
property Position : LongInt read GetPos write SetPos;
property TickFreq : Integer read iTickFreq write SetTickFreq default 1;
property Style : tbStyles read Styles write SetStyles;
property PageSize : LongInt read iPageSize write SetPageSize default 2;
property LineSize : LongInt read iLineSize write SetLineSize default 1;
property ThumbLength : Integer read iThumbLength write SetThumbLength default 19;
property Visible;
property Enabled;
property OnLineUp : TNotifyEvent read EvLineUp write EvLineUp;
property OnLineDown : TNotifyEvent read EvLineDown write EvLineDown;
property OnPageUp : TNotifyEvent read EvPageUp write EvPageUp;
property OnPageDown : TNotifyEvent read EvPageDown write EvPageDown;
property OnThumbPosition : TNotifyEvent read EvThumbPosition write EvThumbPosition;
property OnThumbTrack : TNotifyEvent read EvThumbTrack write EvThumbTrack;
property OnTop : TNotifyEvent read EvTop write EvTop;
property OnBottom : TNotifyEvent read EvBottom write EvBottom;
property OnEndTrack : TNotifyEvent read EvEndTrack write EvEndTrack;
property OnEnter;
property OnExit;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
end;
procedure Register;
implementation
uses commctrl;
constructor TTrackbar.Create (AOwner : TComponent);
begin
inherited Create (AOwner);
Width := 200;
Height := 30;
iTickFreq := 1;
iLineSize := 1;
iPageSize := 2;
iThumbLength := 19;
iMax := 10;
end;
procedure TTrackbar.CreateParams (var Params: TCreateParams);
begin
InitCommonControls;
inherited CreateParams(Params);
CreateSubClass(Params, 'msctls_trackbar');
if tbAutoticks in Styles then with Params do Style := Style or TBS_AUTOTICKS;
if tbVert in styles then with Params do Style := Style or TBS_VERT;
if tbReversed in styles then with Params do Style := Style or TBS_LEFT;
if tbBoth in styles then with Params do Style := Style or TBS_BOTH;
if tbNoTicks in styles then with Params do Style := Style or TBS_NOTICKS;
if SelectionStart <> SelectionEnd then styles := styles + [tbEnableSelRange];
if tbEnableSelRange in styles then with Params do Style := Style or TBS_ENABLESELRANGE;
if tbFixedLength in styles then with Params do Style := Style or TBS_FIXEDLENGTH;
if tbNoThumb in styles then with Params do Style := Style or TBS_NOTHUMB;
end;
procedure TTrackbar.CreateHandle;
var temp : LongInt;
begin
inherited CreateHandle;
if Max <> SendMessage (Handle, TBM_GETRANGEMAX, 0, 0) then
SendMessage (Handle, TBM_SETRANGEMAX, 0, iMax);
if Min <> SendMessage (Handle, TBM_GETRANGEMIN, 0, 0) then
SendMessage (Handle, TBM_SETRANGEMIN, 0, iMin);
if SelectionStart <> SendMessage (Handle, TBM_GETSELSTART, 0, 0) then
SendMessage (Handle, TBM_SETSELSTART, 0, iSelectionStart);
if SelectionEnd <> SendMessage (Handle, TBM_GETSELEND, 0, 0) then
SendMessage (Handle, TBM_SETSELEND, 0, iSelectionEnd);
if iPos <> SendMessage (Handle, TBM_GETPOS, 0, 0) then
SendMessage (Handle, TBM_SETPOS, Ord (True), iPos);
if PageSize <> SendMessage (Handle, TBM_GETPAGESIZE, 0, 0) then
SendMessage (Handle, TBM_SETPAGESIZE, 0, iPageSize);
if LineSize <> SendMessage (Handle, TBM_GETLINESIZE, 0, 0) then
SendMessage (Handle, TBM_SETLINESIZE, 0, iLineSize);
if ThumbLength <> SendMessage (Handle, TBM_GETTHUMBLENGTH, 0, 0) then
SendMessage (Handle, TBM_SETTHUMBLENGTH, iThumbLength, 0);
SendMessage (Handle, TBM_SETTICFREQ, iTickFreq, 0)
end;
procedure TTrackbar.SetMin (value : LongInt);
begin
if iMin <> value then
begin
iMin := value;
SendMessage (Handle, TBM_SETRANGEMIN, Ord (True), iMin)
end
end;
procedure TTrackbar.SetMax (value : LongInt);
begin
if value <> iMax then
begin
iMax := value;
SendMessage (Handle, TBM_SETRANGEMAX, Ord (True), iMax)
end
end;
procedure TTrackbar.SetSelectionStart (value : LongInt);
begin
if iSelectionStart <> value then
begin
iSelectionStart := value;
if SelectionStart <> SelectionEnd then SetStyles (Styles + [tbEnableSelRange]);
SendMessage (Handle, TBM_SETSELSTART, Ord (True), iSelectionStart)
end
end;
procedure TTrackbar.SetSelectionEnd (value : LongInt);
begin
if value <> iSelectionEnd then
begin
iSelectionEnd := value;
SendMessage (Handle, TBM_SETSELEND, Ord (True), iSelectionEnd)
end
end;
procedure TTrackbar.SetPos (value : LongInt);
begin
if value <> iPos then
begin
iPos := value;
SendMessage (Handle, TBM_SETPOS, Ord (True), iPos)
end
end;
function TTrackbar.GetPos : LongInt;
begin
iPos := SendMessage (Handle, TBM_GETPOS, 0, 0);
result := iPos
end;
procedure TTrackbar.SetPageSize (value : LongInt);
begin
if value <> iPageSize then
begin
iPageSize := value;
SendMessage (Handle, TBM_SETPAGESIZE, 0, iPageSize)
end
end;
procedure TTrackbar.SetLineSize (value : LongInt);
begin
if value <> iLineSize then
begin
iLineSize := value;
SendMessage (Handle, TBM_SETLINESIZE, 0, iLineSize)
end
end;
procedure TTrackbar.SetThumbLength (value : Integer);
begin
if value <> iThumbLength then
begin
iThumbLength := value;
SendMessage (Handle, TBM_SETTHUMBLENGTH, value, 0)
end
end;
procedure TTrackbar.SetStyles (value : tbStyles);
begin
if value <> Styles then
begin
Styles := value;
RecreateWnd
end
end;
procedure TTrackbar.SetTickFreq (value : Integer);
begin
if value <> iTickFreq then
begin
iTickFreq := value;
SendMessage (Handle, TBM_SETTICFREQ, value, 0)
end
end;
procedure TTrackbar.SetTic (position : LongInt);
begin
SendMessage (Handle, TBM_SETTIC, 0, position);
end;
function TTrackbar.GetTic (index : Integer) : LongInt;
begin
result := SendMessage (Handle, TBM_GETTIC, index, 0);
end;
function TTrackbar.GetTicPos (index : Integer) : LongInt;
begin
result := SendMessage (Handle, TBM_GETTICPOS, index, 0);
end;
procedure TTrackbar.ClearTics (Redraw : boolean);
begin
SendMessage (Handle, TBM_CLEARTICS, Ord (Redraw), 0);
end;
function TTrackbar.GetNumTics : Integer;
begin
result := SendMessage (Handle, TBM_GETNUMTICS, 0, 0);
end;
procedure TTrackbar.ClearSelection (Redraw : boolean);
begin
SendMessage (Handle, TBM_CLEARSEL, Ord (Redraw), 0);
end;
procedure TTrackbar.GetThumbRect (var Rect : TRect);
begin
SendMessage (Handle, TBM_GETTHUMBRECT, 0, LongInt (@Rect))
end;
procedure TTrackbar.GetChannelRect (var Rect : TRect);
begin
SendMessage (Handle, TBM_GETCHANNELRECT, 0, LongInt (@Rect))
end;
procedure TTrackbar.wmHScroll (var Msg : TMessage);
begin
case Msg.wParam of
TB_LINEUP : if Assigned (EvLineUp) then EvLineUp (self);
TB_LINEDOWN : if Assigned (EvLineDown) then EvLineDown (self);
TB_PAGEUP : if Assigned (EvPageUp) then EvPageUp (self);
TB_PAGEDOWN : if Assigned (EvPageDown) then EvPageDown (self);
TB_THUMBPOSITION : if Assigned (EvThumbPosition) then EvThumbPosition (self);
TB_THUMBTRACK : if Assigned (EvThumbTrack) then EvThumbTrack (self);
TB_TOP : if Assigned (EvTop) then EvTop (self);
TB_BOTTOM : if Assigned (EvBottom) then EvBottom (self);
TB_ENDTRACK : if Assigned (EvEndTrack) then EvEndTrack (self)
end
end;
procedure Register;
begin
RegisterComponents('Windows95', [TTrackbar]);
end;
end.